{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  WumpusExpr.Interp
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Interpret a Wumpus program.
--
--------------------------------------------------------------------------------

module WumpusExpr.Interp
  (
    
    Point(..)
  , interpretK

  ) where

import WumpusExpr.KNormal
import WumpusExpr.Radian
import WumpusExpr.Types
import WumpusExpr.VarId

import Control.Applicative
import qualified Data.Map as M
import Prelude hiding ( lookup )
 
data Point = P2 {-# UNPACK #-} !Decimal {-# UNPACK #-} !Decimal
  deriving (Eq,Show)

zero_P2 :: Point 
zero_P2 = P2 0 0

ptMin :: Point -> Point -> Point 
ptMin (P2 ax ay) (P2 bx by) = P2 (min ax bx) (min ay by)

ptMax :: Point -> Point -> Point 
ptMax (P2 ax ay) (P2 bx by) = P2 (max ax bx) (max ay by)


data BBox = NilBB | BBox !Point !Point
  deriving (Eq,Show)


extBB :: Point -> BBox -> BBox
extBB pt NilBB          = BBox pt pt
extBB pt (BBox bl tr)   = BBox (ptMin pt bl) (ptMax pt tr)


-- | 3x2 matrix in row major form: 
-- 
-- > a b c
-- > d e f
-- > g h i 
--
-- e.g. identity matrix is
--
-- > 1 0 0
-- > 0 1 0
-- > 0 0 1 
--
data CTM = CTM {-# UNPACK #-} !Decimal 
               {-# UNPACK #-} !Decimal 
               {-# UNPACK #-} !Decimal
               {-# UNPACK #-} !Decimal
               {-# UNPACK #-} !Decimal
               {-# UNPACK #-} !Decimal
               {-# UNPACK #-} !Decimal
               {-# UNPACK #-} !Decimal
               {-# UNPACK #-} !Decimal             
  deriving (Eq,Show)


zero_CTM :: CTM
zero_CTM = CTM 1 0 0  1 0 0  0 0 1

infixl 7 /*/, /./

(/*/) :: CTM -> CTM -> CTM
(/*/) (CTM a b c d e f g h i) (CTM m n o p q r s t u) = 
      CTM (a*m+b*p+c*s) (a*n+b*q+c*t) (a*o+b*r+c*u) 
           (d*m+e*p+f*s) (d*n+e*q+f*t) (d*o+e*r+f*u) 
           (g*m+h*p+i*s) (g*n+h*q+i*t) (g*o+h*r+i*u) 

(/./) :: CTM -> Point -> Point
(/./) (CTM a b c d e f _ _ _) (P2 m n) = P2 (a*m + b*n + c*1) 
                                            (d*m + e*n + f*1)

translationMatrix :: Decimal -> Decimal -> CTM
translationMatrix x y = CTM  1 0 x
                             0 1 y
                             0 0 1

rotationMatrix :: Radian -> CTM
rotationMatrix r = CTM (realToFrac $ cos r) (realToFrac $ negate $ sin r) 0
                       (realToFrac $ sin r) (realToFrac $ cos r)          0
                       0                    0                             1

scalingMatrix :: Decimal -> Decimal -> CTM
scalingMatrix sx sy = CTM  sx   0  0   
                            0  sy  0   
                            0   0  1

-- Don\'t worry about colour, line style etc.
-- 
-- At some point we need to consider font size...
-- 
data GraphicsState = GS 
      { current_point :: Point
      , current_ctm   :: CTM
      }
  deriving (Eq,Show)


zero_GS :: GraphicsState
zero_GS = GS { current_point = zero_P2
             , current_ctm   = zero_CTM
             }

type ErrMsg = String


type Env = M.Map VarId Expr

type Funs = M.Map VarId Fundef



-- TODO - needs an env for let-defs in the expression language...

-- | Interpretation is via a state monad with a graphics state 
-- (stack of CTMs).
--
-- Thread /answer/ bounding box as state rather than writer.
--
newtype InterpM a = InterpM { 
    getInterpM :: Funs -> Env -> [GraphicsState] -> BBox ->
                    Either ErrMsg (a, [GraphicsState], BBox) }

instance Functor InterpM where
  fmap f ma = InterpM $ \r1 r2 s bb -> 
                getInterpM ma r1 r2 s bb >>= \(a,s1,bb1) -> 
                return (f a, s1,bb1)



instance Applicative InterpM where
  pure a    = InterpM $ \_  _  s bb -> return (a,s,bb)
  mf <*> ma = InterpM $ \r1 r2 s bb -> 
                getInterpM mf r1 r2 s  bb  >>= \(f,s1,bb1) ->
                getInterpM ma r1 r2 s1 bb1 >>= \(a,s2,bb2) -> 
                return (f a,s2,bb2)


instance Monad InterpM where
  return    = pure
  ma >>= k  = InterpM $ \r1 r2 s bb -> 
                getInterpM ma r1 r2 s bb      >>= \(a,s1,bb1) -> 
                getInterpM (k a) r1 r2 s1 bb1 >>= \(b,s2,bb2) -> 
                return (b,s2,bb2)


runInterpM:: InterpM a -> Either ErrMsg (Point,Point)
runInterpM ma = getInterpM ma M.empty M.empty [] NilBB >>= \(_,_,bb) -> fn bb
  where
    fn NilBB        = Left "No content - empty bounding box"
    fn (BBox bl tr) = Right (bl,tr)


interpretK :: Program -> Either ErrMsg (Point,Point)
interpretK (Program main_proc defs) = 
    runInterpM (withDefs defs $ interpMain main_proc)

withDefs :: [Fundef] -> InterpM a -> InterpM a
withDefs funs ma = InterpM $ \r1 r2 s bb -> 
                      getInterpM ma (ext r1 funs) r2 s bb
  where
    ext = foldr (\fun m -> M.insert (fun_name fun) fun m)


throwError :: ErrMsg -> InterpM a
throwError msg = InterpM $ \_ _ _ _ -> Left msg

-- | Vars should always have a definition... (true?)
--
lookup :: VarId -> InterpM Expr
lookup v = InterpM $ \_ r2 s bb -> case M.lookup v r2 of
              Nothing -> Left $ "lookup fail " ++ varName v
              Just e  -> Right (e,s,bb)

bind :: VarId -> Expr -> InterpM a -> InterpM a
bind v e ma = InterpM $ \r1 r2 s bb -> 
                getInterpM ma r1 (M.insert v e r2) s bb

lookupFun :: VarId -> InterpM Fundef
lookupFun v = InterpM $ \r1 _ s bb -> case M.lookup v r1 of
                Nothing -> Left $ "lookupFun fail " ++ varName v
                Just def -> Right (def,s,bb)


top :: InterpM GraphicsState
top = InterpM $ \_ _ s bb -> go s bb
  where
    go []       bb = return (zero_GS, [], bb)
    go st@(s:_) bb = return (s, st, bb)
 

gsave :: InterpM ()
gsave = InterpM $ \_ _ s bb -> go s bb
  where
    go []       bb = return ((), [zero_GS], bb)
    go ss@(s:_) bb = return ((), (s:ss), bb)




grestore :: InterpM ()
grestore = InterpM $ \_ _ s bb -> go s bb
  where
    go []     bb = return ((), [], bb)
    go (_:ss) bb = return ((), ss, bb)


gmodify :: (GraphicsState -> GraphicsState) -> InterpM ()
gmodify f = InterpM $ \_ _ s bb -> go s bb
  where
    go []     bb = return ((), [f zero_GS], bb)
    go (s:ss) bb = return ((), f s : ss, bb)


-- | Note - this is an absolute move.
--
move :: Decimal -> Decimal -> InterpM ()
move x y = gmodify fn
  where
    fn = (\s (P2 x0 y0) -> s { current_point = P2 (x0+x) (y0+y) }) 
             <*> current_point


tellCurrentPos :: InterpM ()
tellCurrentPos = top >>= \gs -> 
   let pt  = current_point gs
       ctm = current_ctm gs
   in InterpM $ \_ _ s bb -> return ((), s, extBB (ctm /./ pt) bb)



translate :: Decimal -> Decimal -> InterpM ()
translate dx dy = gmodify $ 
    (\s ctm -> s { current_ctm = ctm /*/ translationMatrix dx dy }) 
      <*> current_ctm

scale :: Decimal -> Decimal -> InterpM ()
scale sx sy = gmodify $ 
    (\s ctm -> s { current_ctm = ctm /*/ scalingMatrix sx sy }) 
      <*> current_ctm

-- | Should we add Radian as a type?
--
-- > rotate :: Radian -> ()   (Canvas)
--
-- > rotate :: Degree -> ()   (PostScript)
-- 
-- If we have Radian as a distinct type we know we have to print 
-- it as Radian in JS and as Degree in PS.
--

rotate :: Radian -> InterpM ()
rotate r = gmodify $ 
    (\s ctm -> s { current_ctm = ctm /*/ rotationMatrix r}) <*> current_ctm


transform :: Decimal -> Decimal -> Decimal -> Decimal -> Decimal -> Decimal 
          -> InterpM ()
transform a b c d e f = gmodify $ 
    (\s ctm -> s { current_ctm = ctm /*/ CTM a b 0 c d 0 e f 1 }) 
      <*> current_ctm



interpMain :: Fundef -> InterpM ()
interpMain (Fundef _ _ expr) = expression expr >> return ()


expression :: Expr -> InterpM Value
expression (Val v)              = case v of 
    Var vid -> lookup vid >>= expression
    val     -> return val

expression (FunCall vid args)   = invoke vid args

-- Evalute let head at the call site...
expression (Let v e1 e2)        = bind v e1 (expression e2)

expression (Cmd cmd)            = command cmd   >> return Unit
expression (e1 :>> e2)          = expression e1 >> expression e2
expression (Return e)           = expression e
expression _                    = return Unit 


invoke :: VarId -> [Value] -> InterpM Value
invoke fun_id args = lookupFun fun_id >>= \(Fundef _ arg_names body) -> 
    expression (expandArgs arg_names args $ body)
  where
    expandArgs (x:xs) (y:ys) body = Let x (Val y) $ expandArgs xs ys body
    expandArgs _      _      body = body




command :: Command -> InterpM ()
command (MoveTo x1 y1)                  = do 
    x <- valueDecimal x1
    y <- valueDecimal y1
    move x y
    
command (LineTo x1 y1)                  = do
    tellCurrentPos
    x <- valueDecimal x1
    y <- valueDecimal y1
    move x y
    tellCurrentPos

command (CurveTo x1 y1 x2 y2 x3 y3)     = do
    tellCurrentPos
    xa <- valueDecimal x1
    ya <- valueDecimal y1
    move xa ya
    tellCurrentPos
    xb <- valueDecimal x2
    yb <- valueDecimal y2
    move xb yb
    tellCurrentPos
    xc <- valueDecimal x3
    yc <- valueDecimal y3
    move xc yc
    tellCurrentPos

command (GSave)                         = gsave
command (GRestore)                      = grestore
command (Scale x1 y1)                   = do
    x <- valueDecimal x1
    y <- valueDecimal y1
    scale x y

command (Translate x1 y1)               = do
    x <- valueDecimal x1
    y <- valueDecimal y1
    translate x y

command (Rotate ang)                    = valueRadian ang >>= rotate
command (Transform a1 b1 c1 d1 e1 f1)   = do
    a <- valueDecimal a1
    b <- valueDecimal b1
    c <- valueDecimal c1
    d <- valueDecimal d1
    e <- valueDecimal e1
    f <- valueDecimal f1
    transform a b c d e f

-- Showtext not currently handled...

command _                               = return ()


valueDecimal :: Value -> InterpM Decimal
valueDecimal (Float d) = return d
valueDecimal (Var v)   = lookup v >>= expression >>= valueDecimal
valueDecimal _         = throwError "valueDecimal - ouch"


valueRadian :: Value -> InterpM Radian
valueRadian (Angle d) = return d
valueRadian (Var v)   = lookup v >>= expression >>= valueRadian
valueRadian _         = throwError "valueRadian - ouch"
